home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / perl / 5.10.1 / NEXT.pm < prev    next >
Encoding:
Perl POD Document  |  2012-12-11  |  18.0 KB  |  564 lines
  1. package NEXT;
  2. $VERSION = '0.64';
  3. use Carp;
  4. use strict;
  5. use overload ();
  6.  
  7. sub NEXT::ELSEWHERE::ancestors
  8. {
  9.     my @inlist = shift;
  10.     my @outlist = ();
  11.     while (my $next = shift @inlist) {
  12.         push @outlist, $next;
  13.         no strict 'refs';
  14.         unshift @inlist, @{"$outlist[-1]::ISA"};
  15.     }
  16.     return @outlist;
  17. }
  18.  
  19. sub NEXT::ELSEWHERE::ordered_ancestors
  20. {
  21.     my @inlist = shift;
  22.     my @outlist = ();
  23.     while (my $next = shift @inlist) {
  24.         push @outlist, $next;
  25.         no strict 'refs';
  26.         push @inlist, @{"$outlist[-1]::ISA"};
  27.     }
  28.     return sort { $a->isa($b) ? -1
  29.                 : $b->isa($a) ? +1
  30.                 :                0 } @outlist;
  31. }
  32.  
  33. sub NEXT::ELSEWHERE::buildAUTOLOAD
  34. {
  35.     my $autoload_name = caller() . '::AUTOLOAD';
  36.  
  37.     no strict 'refs';
  38.     *{$autoload_name} = sub {
  39.         my ($self) = @_;
  40.         my $depth = 1;
  41.         until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
  42.         my $caller = (caller($depth))[3];
  43.         my $wanted = $NEXT::AUTOLOAD || $autoload_name;
  44.         undef $NEXT::AUTOLOAD;
  45.         my ($caller_class, $caller_method) = do { $caller =~ m{(.*)::(.*)}g };
  46.         my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g };
  47.         croak "Can't call $wanted from $caller"
  48.             unless $caller_method eq $wanted_method;
  49.  
  50.         my $key = ref $self && overload::Overloaded($self)
  51.             ? overload::StrVal($self) : $self;
  52.  
  53.         local ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN) =
  54.             ($NEXT::NEXT{$key,$wanted_method}, $NEXT::SEEN);
  55.  
  56.         unless ($NEXT::NEXT{$key,$wanted_method}) {
  57.             my @forebears =
  58.                 NEXT::ELSEWHERE::ancestors ref $self || $self,
  59.                             $wanted_class;
  60.             while (@forebears) {
  61.                 last if shift @forebears eq $caller_class
  62.             }
  63.             no strict 'refs';
  64.             @{$NEXT::NEXT{$key,$wanted_method}} =
  65.                 map {
  66.                     my $stash = \%{"${_}::"};
  67.                     ($stash->{$caller_method} && (*{$stash->{$caller_method}}{CODE}))
  68.                         ? *{$stash->{$caller_method}}{CODE}
  69.                         : () } @forebears
  70.                     unless $wanted_method eq 'AUTOLOAD';
  71.             @{$NEXT::NEXT{$key,$wanted_method}} =
  72.                 map {
  73.                     my $stash = \%{"${_}::"};
  74.                     ($stash->{AUTOLOAD} && (*{$stash->{AUTOLOAD}}{CODE}))
  75.                         ? "${_}::AUTOLOAD"
  76.                         : () } @forebears
  77.                     unless @{$NEXT::NEXT{$key,$wanted_method}||[]};
  78.             $NEXT::SEEN->{$key,*{$caller}{CODE}}++;
  79.         }
  80.         my $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
  81.         while (do { $wanted_class =~ /^NEXT\b.*\b(UNSEEN|DISTINCT)\b/ }
  82.             && defined $call_method
  83.             && $NEXT::SEEN->{$key,$call_method}++) {
  84.             $call_method = shift @{$NEXT::NEXT{$key,$wanted_method}};
  85.         }
  86.         unless (defined $call_method) {
  87.             return unless do { $wanted_class =~ /^NEXT:.*:ACTUAL/ };
  88.             (local $Carp::CarpLevel)++;
  89.             croak qq(Can't locate object method "$wanted_method" ),
  90.                 qq(via package "$caller_class");
  91.         };
  92.         return $self->$call_method(@_[1..$#_]) if ref $call_method eq 'CODE';
  93.         no strict 'refs';
  94.         do { ($wanted_method=${$caller_class."::AUTOLOAD"}) =~ s/.*::// }
  95.             if $wanted_method eq 'AUTOLOAD';
  96.         $$call_method = $caller_class."::NEXT::".$wanted_method;
  97.         return $call_method->(@_);
  98.     };
  99. }
  100.  
  101. no strict 'vars';
  102. package NEXT;                                  NEXT::ELSEWHERE::buildAUTOLOAD();
  103. package NEXT::UNSEEN;        @ISA = 'NEXT';     NEXT::ELSEWHERE::buildAUTOLOAD();
  104. package NEXT::DISTINCT;        @ISA = 'NEXT';     NEXT::ELSEWHERE::buildAUTOLOAD();
  105. package NEXT::ACTUAL;        @ISA = 'NEXT';     NEXT::ELSEWHERE::buildAUTOLOAD();
  106. package NEXT::ACTUAL::UNSEEN;    @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
  107. package NEXT::ACTUAL::DISTINCT;    @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
  108. package NEXT::UNSEEN::ACTUAL;    @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
  109. package NEXT::DISTINCT::ACTUAL;    @ISA = 'NEXT'; NEXT::ELSEWHERE::buildAUTOLOAD();
  110.  
  111. package EVERY;
  112.  
  113. sub EVERY::ELSEWHERE::buildAUTOLOAD {
  114.     my $autoload_name = caller() . '::AUTOLOAD';
  115.  
  116.     no strict 'refs';
  117.     *{$autoload_name} = sub {
  118.         my ($self) = @_;
  119.         my $depth = 1;
  120.         until (((caller($depth))[3]||q{}) !~ /^\(eval\)$/) { $depth++ }
  121.         my $caller = (caller($depth))[3];
  122.         my $wanted = $EVERY::AUTOLOAD || $autoload_name;
  123.         undef $EVERY::AUTOLOAD;
  124.         my ($wanted_class, $wanted_method) = do { $wanted =~ m{(.*)::(.*)}g };
  125.  
  126.         my $key = ref($self) && overload::Overloaded($self)
  127.             ? overload::StrVal($self) : $self;
  128.  
  129.         local $NEXT::ALREADY_IN_EVERY{$key,$wanted_method} =
  130.             $NEXT::ALREADY_IN_EVERY{$key,$wanted_method};
  131.  
  132.         return if $NEXT::ALREADY_IN_EVERY{$key,$wanted_method}++;
  133.  
  134.         my @forebears = NEXT::ELSEWHERE::ordered_ancestors ref $self || $self,
  135.                                         $wanted_class;
  136.         @forebears = reverse @forebears if do { $wanted_class =~ /\bLAST\b/ };
  137.         no strict 'refs';
  138.         my %seen;
  139.         my @every = map { my $sub = "${_}::$wanted_method";
  140.                     !*{$sub}{CODE} || $seen{$sub}++ ? () : $sub
  141.                     } @forebears
  142.                     unless $wanted_method eq 'AUTOLOAD';
  143.  
  144.         my $want = wantarray;
  145.         if (@every) {
  146.             if ($want) {
  147.                 return map {($_, [$self->$_(@_[1..$#_])])} @every;
  148.             }
  149.             elsif (defined $want) {
  150.                 return { map {($_, scalar($self->$_(@_[1..$#_])))}
  151.                         @every
  152.                     };
  153.             }
  154.             else {
  155.                 $self->$_(@_[1..$#_]) for @every;
  156.                 return;
  157.             }
  158.         }
  159.  
  160.         @every = map { my $sub = "${_}::AUTOLOAD";
  161.                 !*{$sub}{CODE} || $seen{$sub}++ ? () : "${_}::AUTOLOAD"
  162.                 } @forebears;
  163.         if ($want) {
  164.             return map { $$_ = ref($self)."::EVERY::".$wanted_method;
  165.                     ($_, [$self->$_(@_[1..$#_])]);
  166.                 } @every;
  167.         }
  168.         elsif (defined $want) {
  169.             return { map { $$_ = ref($self)."::EVERY::".$wanted_method;
  170.                     ($_, scalar($self->$_(@_[1..$#_])))
  171.                     } @every
  172.                 };
  173.         }
  174.         else {
  175.             for (@every) {
  176.                 $$_ = ref($self)."::EVERY::".$wanted_method;
  177.                 $self->$_(@_[1..$#_]);
  178.             }
  179.             return;
  180.         }
  181.     };
  182. }
  183.  
  184. package EVERY::LAST;   @ISA = 'EVERY';   EVERY::ELSEWHERE::buildAUTOLOAD();
  185. package EVERY;         @ISA = 'NEXT';    EVERY::ELSEWHERE::buildAUTOLOAD();
  186.  
  187. 1;
  188.  
  189. __END__
  190.  
  191. =head1 NAME
  192.  
  193. NEXT.pm - Provide a pseudo-class NEXT (et al) that allows method redispatch
  194.  
  195.  
  196. =head1 SYNOPSIS
  197.  
  198.     use NEXT;
  199.  
  200.     package A;
  201.     sub A::method   { print "$_[0]: A method\n";   $_[0]->NEXT::method() }
  202.     sub A::DESTROY  { print "$_[0]: A dtor\n";     $_[0]->NEXT::DESTROY() }
  203.  
  204.     package B;
  205.     use base qw( A );
  206.     sub B::AUTOLOAD { print "$_[0]: B AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  207.     sub B::DESTROY  { print "$_[0]: B dtor\n";     $_[0]->NEXT::DESTROY() }
  208.  
  209.     package C;
  210.     sub C::method   { print "$_[0]: C method\n";   $_[0]->NEXT::method() }
  211.     sub C::AUTOLOAD { print "$_[0]: C AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  212.     sub C::DESTROY  { print "$_[0]: C dtor\n";     $_[0]->NEXT::DESTROY() }
  213.  
  214.     package D;
  215.     use base qw( B C );
  216.     sub D::method   { print "$_[0]: D method\n";   $_[0]->NEXT::method() }
  217.     sub D::AUTOLOAD { print "$_[0]: D AUTOLOAD\n"; $_[0]->NEXT::AUTOLOAD() }
  218.     sub D::DESTROY  { print "$_[0]: D dtor\n";     $_[0]->NEXT::DESTROY() }
  219.  
  220.     package main;
  221.  
  222.     my $obj = bless {}, "D";
  223.  
  224.     $obj->method();        # Calls D::method, A::method, C::method
  225.     $obj->missing_method(); # Calls D::AUTOLOAD, B::AUTOLOAD, C::AUTOLOAD
  226.  
  227.     # Clean-up calls D::DESTROY, B::DESTROY, A::DESTROY, C::DESTROY
  228.  
  229.  
  230.  
  231. =head1 DESCRIPTION
  232.  
  233. NEXT.pm adds a pseudoclass named C<NEXT> to any program
  234. that uses it. If a method C<m> calls C<$self-E<gt>NEXT::m()>, the call to
  235. C<m> is redispatched as if the calling method had not originally been found.
  236.  
  237. In other words, a call to C<$self-E<gt>NEXT::m()> resumes the depth-first,
  238. left-to-right search of C<$self>'s class hierarchy that resulted in the
  239. original call to C<m>.
  240.  
  241. Note that this is not the same thing as C<$self-E<gt>SUPER::m()>, which
  242. begins a new dispatch that is restricted to searching the ancestors
  243. of the current class. C<$self-E<gt>NEXT::m()> can backtrack
  244. past the current class -- to look for a suitable method in other
  245. ancestors of C<$self> -- whereas C<$self-E<gt>SUPER::m()> cannot.
  246.  
  247. A typical use would be in the destructors of a class hierarchy,
  248. as illustrated in the synopsis above. Each class in the hierarchy
  249. has a DESTROY method that performs some class-specific action
  250. and then redispatches the call up the hierarchy. As a result,
  251. when an object of class D is destroyed, the destructors of I<all>
  252. its parent classes are called (in depth-first, left-to-right order).
  253.  
  254. Another typical use of redispatch would be in C<AUTOLOAD>'ed methods.
  255. If such a method determined that it was not able to handle a
  256. particular call, it might choose to redispatch that call, in the
  257. hope that some other C<AUTOLOAD> (above it, or to its left) might
  258. do better.
  259.  
  260. By default, if a redispatch attempt fails to find another method
  261. elsewhere in the objects class hierarchy, it quietly gives up and does
  262. nothing (but see L<"Enforcing redispatch">). This gracious acquiescence
  263. is also unlike the (generally annoying) behaviour of C<SUPER>, which
  264. throws an exception if it cannot redispatch.
  265.  
  266. Note that it is a fatal error for any method (including C<AUTOLOAD>)
  267. to attempt to redispatch any method that does not have the
  268. same name. For example:
  269.  
  270.         sub D::oops { print "oops!\n"; $_[0]->NEXT::other_method() }
  271.  
  272.  
  273. =head2 Enforcing redispatch
  274.  
  275. It is possible to make C<NEXT> redispatch more demandingly (i.e. like
  276. C<SUPER> does), so that the redispatch throws an exception if it cannot
  277. find a "next" method to call.
  278.  
  279. To do this, simple invoke the redispatch as:
  280.  
  281.     $self->NEXT::ACTUAL::method();
  282.  
  283. rather than:
  284.  
  285.     $self->NEXT::method();
  286.  
  287. The C<ACTUAL> tells C<NEXT> that there must actually be a next method to call,
  288. or it should throw an exception.
  289.  
  290. C<NEXT::ACTUAL> is most commonly used in C<AUTOLOAD> methods, as a means to
  291. decline an C<AUTOLOAD> request, but preserve the normal exception-on-failure 
  292. semantics:
  293.  
  294.     sub AUTOLOAD {
  295.         if ($AUTOLOAD =~ /foo|bar/) {
  296.             # handle here
  297.         }
  298.         else {  # try elsewhere
  299.             shift()->NEXT::ACTUAL::AUTOLOAD(@_);
  300.         }
  301.     }
  302.  
  303. By using C<NEXT::ACTUAL>, if there is no other C<AUTOLOAD> to handle the
  304. method call, an exception will be thrown (as usually happens in the absence of
  305. a suitable C<AUTOLOAD>).
  306.  
  307.  
  308. =head2 Avoiding repetitions
  309.  
  310. If C<NEXT> redispatching is used in the methods of a "diamond" class hierarchy:
  311.  
  312.     #     A   B
  313.     #    / \ /
  314.     #   C   D
  315.     #    \ /
  316.     #     E
  317.  
  318.     use NEXT;
  319.  
  320.     package A;                 
  321.     sub foo { print "called A::foo\n"; shift->NEXT::foo() }
  322.  
  323.     package B;                 
  324.     sub foo { print "called B::foo\n"; shift->NEXT::foo() }
  325.  
  326.     package C; @ISA = qw( A );
  327.     sub foo { print "called C::foo\n"; shift->NEXT::foo() }
  328.  
  329.     package D; @ISA = qw(A B);
  330.     sub foo { print "called D::foo\n"; shift->NEXT::foo() }
  331.  
  332.     package E; @ISA = qw(C D);
  333.     sub foo { print "called E::foo\n"; shift->NEXT::foo() }
  334.  
  335.     E->foo();
  336.  
  337. then derived classes may (re-)inherit base-class methods through two or
  338. more distinct paths (e.g. in the way C<E> inherits C<A::foo> twice --
  339. through C<C> and C<D>). In such cases, a sequence of C<NEXT> redispatches
  340. will invoke the multiply inherited method as many times as it is
  341. inherited. For example, the above code prints:
  342.  
  343.         called E::foo
  344.         called C::foo
  345.         called A::foo
  346.         called D::foo
  347.         called A::foo
  348.         called B::foo
  349.  
  350. (i.e. C<A::foo> is called twice).
  351.  
  352. In some cases this I<may> be the desired effect within a diamond hierarchy,
  353. but in others (e.g. for destructors) it may be more appropriate to 
  354. call each method only once during a sequence of redispatches.
  355.  
  356. To cover such cases, you can redispatch methods via:
  357.  
  358.         $self->NEXT::DISTINCT::method();
  359.  
  360. rather than:
  361.  
  362.         $self->NEXT::method();
  363.  
  364. This causes the redispatcher to only visit each distinct C<method> method
  365. once. That is, to skip any classes in the hierarchy that it has
  366. already visited during redispatch. So, for example, if the
  367. previous example were rewritten:
  368.  
  369.         package A;                 
  370.         sub foo { print "called A::foo\n"; shift->NEXT::DISTINCT::foo() }
  371.  
  372.         package B;                 
  373.         sub foo { print "called B::foo\n"; shift->NEXT::DISTINCT::foo() }
  374.  
  375.         package C; @ISA = qw( A );
  376.         sub foo { print "called C::foo\n"; shift->NEXT::DISTINCT::foo() }
  377.  
  378.         package D; @ISA = qw(A B);
  379.         sub foo { print "called D::foo\n"; shift->NEXT::DISTINCT::foo() }
  380.  
  381.         package E; @ISA = qw(C D);
  382.         sub foo { print "called E::foo\n"; shift->NEXT::DISTINCT::foo() }
  383.  
  384.         E->foo();
  385.  
  386. then it would print:
  387.         
  388.         called E::foo
  389.         called C::foo
  390.         called A::foo
  391.         called D::foo
  392.         called B::foo
  393.  
  394. and omit the second call to C<A::foo> (since it would not be distinct
  395. from the first call to C<A::foo>).
  396.  
  397. Note that you can also use:
  398.  
  399.         $self->NEXT::DISTINCT::ACTUAL::method();
  400.  
  401. or:
  402.  
  403.         $self->NEXT::ACTUAL::DISTINCT::method();
  404.  
  405. to get both unique invocation I<and> exception-on-failure.
  406.  
  407. Note that, for historical compatibility, you can also use
  408. C<NEXT::UNSEEN> instead of C<NEXT::DISTINCT>.
  409.  
  410.  
  411. =head2 Invoking all versions of a method with a single call
  412.  
  413. Yet another pseudo-class that NEXT.pm provides is C<EVERY>.
  414. Its behaviour is considerably simpler than that of the C<NEXT> family.
  415. A call to:
  416.  
  417.     $obj->EVERY::foo();
  418.  
  419. calls I<every> method named C<foo> that the object in C<$obj> has inherited.
  420. That is:
  421.  
  422.     use NEXT;
  423.  
  424.     package A; @ISA = qw(B D X);
  425.     sub foo { print "A::foo " }
  426.  
  427.     package B; @ISA = qw(D X);
  428.     sub foo { print "B::foo " }
  429.  
  430.     package X; @ISA = qw(D);
  431.     sub foo { print "X::foo " }
  432.  
  433.     package D;
  434.     sub foo { print "D::foo " }
  435.  
  436.     package main;
  437.  
  438.     my $obj = bless {}, 'A';
  439.     $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo
  440.  
  441. Prefixing a method call with C<EVERY::> causes every method in the
  442. object's hierarchy with that name to be invoked. As the above example
  443. illustrates, they are not called in Perl's usual "left-most-depth-first"
  444. order. Instead, they are called "breadth-first-dependency-wise".
  445.  
  446. That means that the inheritance tree of the object is traversed breadth-first
  447. and the resulting order of classes is used as the sequence in which methods
  448. are called. However, that sequence is modified by imposing a rule that the
  449. appropriate method of a derived class must be called before the same method of
  450. any ancestral class. That's why, in the above example, C<X::foo> is called
  451. before C<D::foo>, even though C<D> comes before C<X> in C<@B::ISA>.
  452.  
  453. In general, there's no need to worry about the order of calls. They will be
  454. left-to-right, breadth-first, most-derived-first. This works perfectly for
  455. most inherited methods (including destructors), but is inappropriate for
  456. some kinds of methods (such as constructors, cloners, debuggers, and
  457. initializers) where it's more appropriate that the least-derived methods be
  458. called first (as more-derived methods may rely on the behaviour of their
  459. "ancestors"). In that case, instead of using the C<EVERY> pseudo-class:
  460.  
  461.     $obj->EVERY::foo();        # prints" A::foo B::foo X::foo D::foo      
  462.  
  463. you can use the C<EVERY::LAST> pseudo-class:
  464.  
  465.     $obj->EVERY::LAST::foo();  # prints" D::foo X::foo B::foo A::foo      
  466.  
  467. which reverses the order of method call.
  468.  
  469. Whichever version is used, the actual methods are called in the same
  470. context (list, scalar, or void) as the original call via C<EVERY>, and return:
  471.  
  472. =over
  473.  
  474. =item *
  475.  
  476. A hash of array references in list context. Each entry of the hash has the
  477. fully qualified method name as its key and a reference to an array containing
  478. the method's list-context return values as its value.
  479.  
  480. =item *
  481.  
  482. A reference to a hash of scalar values in scalar context. Each entry of the hash has the
  483. fully qualified method name as its key and the method's scalar-context return values as its value.
  484.  
  485. =item *
  486.  
  487. Nothing in void context (obviously).
  488.  
  489. =back
  490.  
  491. =head2 Using C<EVERY> methods
  492.  
  493. The typical way to use an C<EVERY> call is to wrap it in another base
  494. method, that all classes inherit. For example, to ensure that every
  495. destructor an object inherits is actually called (as opposed to just the
  496. left-most-depth-first-est one):
  497.  
  498.         package Base;
  499.         sub DESTROY { $_[0]->EVERY::Destroy }
  500.  
  501.         package Derived1; 
  502.         use base 'Base';
  503.         sub Destroy {...}
  504.  
  505.         package Derived2; 
  506.         use base 'Base', 'Derived1';
  507.         sub Destroy {...}
  508.  
  509. et cetera. Every derived class than needs its own clean-up
  510. behaviour simply adds its own C<Destroy> method (I<not> a C<DESTROY> method),
  511. which the call to C<EVERY::LAST::Destroy> in the inherited destructor
  512. then correctly picks up.
  513.  
  514. Likewise, to create a class hierarchy in which every initializer inherited by
  515. a new object is invoked:
  516.  
  517.         package Base;
  518.         sub new {
  519.         my ($class, %args) = @_;
  520.         my $obj = bless {}, $class;
  521.         $obj->EVERY::LAST::Init(\%args);
  522.     }
  523.  
  524.         package Derived1; 
  525.         use base 'Base';
  526.         sub Init {
  527.         my ($argsref) = @_;
  528.         ...
  529.     }
  530.  
  531.         package Derived2; 
  532.         use base 'Base', 'Derived1';
  533.         sub Init {
  534.         my ($argsref) = @_;
  535.         ...
  536.     }
  537.  
  538. et cetera. Every derived class than needs some additional initialization
  539. behaviour simply adds its own C<Init> method (I<not> a C<new> method),
  540. which the call to C<EVERY::LAST::Init> in the inherited constructor
  541. then correctly picks up.
  542.  
  543.  
  544. =head1 AUTHOR
  545.  
  546. Damian Conway (damian@conway.org)
  547.  
  548. =head1 BUGS AND IRRITATIONS
  549.  
  550. Because it's a module, not an integral part of the interpreter, NEXT.pm
  551. has to guess where the surrounding call was found in the method
  552. look-up sequence. In the presence of diamond inheritance patterns
  553. it occasionally guesses wrong.
  554.  
  555. It's also too slow (despite caching).
  556.  
  557. Comment, suggestions, and patches welcome.
  558.  
  559. =head1 COPYRIGHT
  560.  
  561.  Copyright (c) 2000-2001, Damian Conway. All Rights Reserved.
  562.  This module is free software. It may be used, redistributed
  563.     and/or modified under the same terms as Perl itself.
  564.